BBS in a Box 4/BBS in a Box - Macintosh - Volume IV (January 1992) (BBS in a Box).iso/Files/Prog/B-C/ColorCollect.p

Text File | 1991-02-23 | 14.0 KB | 582 lines | [TEXT/MACA]

Program ColorCollect;

(*

purpose    To demonstrate figuring out the colors used in a picture.
                It figures out which colors a picture uses,
                attaches a palette to a color window, and displays the picture.

                This program was written by Darin Adler, 2/88
                based on SillyBalls by Bo3b Johnson.

                You can build the program with this:

Pascal ColorCollect.p
Link ColorCollect.p.o ∂
    "{Libraries}Interface.o" ∂
    "{Libraries}Runtime.o" ∂
    "{PLibraries}PasLib.o" ∂
    -o ColorCollect
ColorCollect

*)

USES
    MemTypes, QuickDraw, OSIntf, ToolIntf, PackIntf, PaletteMgr;

TYPE
    BitMapPtr = ^BitMap;

VAR
    gWindow:    WindowPtr;


{ Figure out whether a BitMap is really a PixMap, and return a PixMapPtr. }

Function GetPixMapPtr(bitPtr: BitMapPtr): PixMapPtr;

{ If this BitMap is a real BitMap, return NIL.  There are three cases here:
    1) real BitMap; high bit (PixMapBit) of rowBytes not set
    2) pointer to PixMap; high bit (PixMapBit) of rowBytes set
    3) pointer to PixMapHandle in a port; both high bits of rowBytes set}

    CONST
        PixMapBit = 15;
        PortPixMapBit = 14;

    TYPE
        PixMapHandlePtr = ^PixMapHandle;    {used for tricky stuff with PixMaps}

    BEGIN
    WITH bitPtr^ DO
        IF BTst(rowBytes, PixMapBit) THEN
            IF BTst(rowBytes, PortPixMapBit) THEN
                { If both high bits are set, we have a pointer to a PixMapHandle. }
                GetPixMapPtr := PixMapHandlePtr(bitPtr)^^
            ELSE
                { If one high bit of rowBytes is set, we have a pointer to a
                    PixMap, which is just what we want. }
                GetPixMapPtr := PixMapPtr(bitPtr)
        ELSE
            { If the high bit of rowBytes is not set, we don't have a PixMap. }
            GetPixMapPtr := NIL;
    END;


{ Bottlenecks for CollectColors routine below. }

VAR
    gColorError:        OSErr;            { Used to report errors from bottlenecks. }
    gColorTable:        CTabHandle;    { Used to collect colors from bottlenecks. }


{ Given a value for ctSize, calculate the size that the color table should be. }

Function SizeOfColorTable(ctSize: Integer): LongInt;

BEGIN
    SizeOfColorTable := SizeOf(ColorTable) + SizeOf(ColorSpec) *
        LongInt(ctSize);
END;


{ Check if the two colors are identical. }

Function EqualColor(color1, color2: RGBColor): Boolean;

BEGIN
    EqualColor := (color1.red = color2.red) AND (color1.green = color2.green)
        AND (color1.blue = color2.blue);
END;


{ Check if a color is already in the color table. }

Function ColorInTable(color: RGBColor): Boolean;

VAR
    index: Integer;

BEGIN
    WITH gColorTable^^ DO
        FOR index := 0 TO ctSize DO
            { We have to turn off range checking here so that we can index into
                ctTable.  It is declared as an ARRAY[0..0], but it has more than one
                element. }
            {$PUSH}{$R-}
            IF EqualColor(color, ctTable[index].rgb) THEN BEGIN
            { This sets the options (range checking) back. }
            {$POP}
                ColorInTable := TRUE;
                EXIT(ColorInTable);
            END;
    ColorInTable := FALSE;
END;


{ Add a color to the color table. }

Procedure AddRGBColor(color: RGBColor);

BEGIN
    { Don't add any more colors if there has already been a color error. }
    IF gColorError = noErr THEN
        { Don't add a color if it is already in the table. }
        IF NOT ColorInTable(color) THEN BEGIN
            WITH gColorTable^^ DO BEGIN
                { Add an entry to the color table. }
                ctSize := ctSize + 1;
                SetHandleSize(Handle(gColorTable), SizeOfColorTable(ctSize));
                gColorError := MemError;
            END;
            IF gColorError = noErr THEN
                WITH gColorTable^^ DO
                    { We have to turn off range checking here so that we can index
                        into ctTable.  It is declared as an ARRAY[0..0], but it has more
                        than one element. }
                    {$PUSH}{$R-}
                    ctTable[ctSize].rgb := color;
                    { This sets the options (range checking) back. }
                    {$POP}
        END;
END;


{ Add the contents of another color table to our color table. }

Procedure AddColorTable(cTab: CTabHandle);

VAR
    index:    Integer;

BEGIN
    FOR index := 0 TO cTab^^.ctSize DO
        { We have to turn off range checking here so that we can index into
            ctTable.  It is declared as an ARRAY[0..0], but it has more than one
            element. }
        {$PUSH}{$R-}
        AddRGBColor(cTab^^.ctTable[index].rgb);
        { This sets the options (range checking) back. }
        {$POP}
END;


{ Add the foreground color of the current port to the color table. }

Procedure AddRGBForeColor;

BEGIN
    AddRGBColor(CGrafPtr(thePort)^.rgbFgColor);
END;


{ Add the background color of the current port to the color table. }

Procedure AddRGBBackColor;

BEGIN
    AddRGBColor(CGrafPtr(thePort)^.rgbBkColor);
END;


{ Add colors from a PixPat to a color table. }

Procedure AddPixPat(pPat: PixPatHandle);

BEGIN
    CASE pPat^^.patType OF
        0: BEGIN
            { Type 0 PixPats are one-bit patterns; they are drawn in the
                foreground and background color. }
            AddRGBForeColor;
            AddRGBBackColor;
        END;
        1:
            { Type 1 PixPats have a color table. }
            AddColorTable(pPat^^.patMap^^.pmTable);
    END;
END;


{ Add colors from the pen PixPat to the color table. }

Procedure AddPenPixPat;

BEGIN
    AddPixPat(CGrafPtr(thePort)^.pnPixPat);
END;


{ Add colors from the fill PixPat to the color table. }

Procedure AddFillPixPat;

BEGIN
    AddPixPat(CGrafPtr(thePort)^.fillPixPat);
END;


{ Add colors because we are about to draw some text. }

Procedure ColorTextProc(byteCount: Integer; textBuf: Ptr; numer, denom:
    Point);

BEGIN
    { Text is drawn with the foreground and background colors. }
    AddRGBForeColor;
    AddRGBBackColor;
        DebugStr('Text')

END;


{ Add colors because we are about to draw a line. }

Procedure ColorLineProc(newPt: Point);

BEGIN
    { Lines are drawn with the pen PixPat. }
    AddPenPixPat;
        DebugStr('Line')

END;


{ Add colors because we are about to draw an object. }

Procedure AddVerb(verb: GrafVerb);

BEGIN
    CASE verb OF
        frame, paint:
            { Framed objects and painted objects are drawn in the pen PixPat. }
            AddPenPixPat;
        erase:
            { Erased objects are drawn in the background color. }
            AddRGBBackColor;
        fill:
            { Filled objects are drawn in the fill PixPat.  The fillPixPat is
                a pattern used to record fill commands for pictures.  First, a
                command to set the fillPixPat is recorded, then the fill command
                is recorded. }
            AddFillPixPat;
    END;
END;


{ Add colors because we are about to draw a rectangle. }

Procedure ColorRectProc(verb: GrafVerb; r: Rect);

BEGIN
    { Each verb is different (Frame, Paint, Erase, Fill). }
    AddVerb(verb);
        DebugStr('Rect')

END;


{ Add colors because we are about to draw a rounded rectangle. }

Procedure ColorRRectProc(verb: GrafVerb; r: Rect; ovalWidth, ovalHeight:
    Integer);

BEGIN
    { Each verb is different (Frame, Paint, Erase, Fill). }
    AddVerb(verb);
        DebugStr('RRect')

END;


{ Add colors because we are about to draw an oval. }

Procedure ColorOvalProc(verb: GrafVerb; r: Rect);

BEGIN
    { Each verb is different (Frame, Paint, Erase, Fill). }
    AddVerb(verb);
        DebugStr('Oval')

END;


{ Add colors because we are about to draw an arc. }

Procedure ColorArcProc(verb: GrafVerb; r: Rect; startAngle, arcAngle:
    Integer);

BEGIN
    { Each verb is different (Frame, Paint, Erase, Fill). }
    AddVerb(verb);
        DebugStr('Arc')

END;


{ Add colors because we are about to draw a polygon. }

Procedure ColorPolyProc(verb: GrafVerb; poly: PolyHandle);

BEGIN
    { Each verb is different (Frame, Paint, Erase, Fill). }
    AddVerb(verb);
        DebugStr('Poly');
        StdPoly(verb, poly);

END;


{ Add colors because we are about to draw a region. }

Procedure ColorRgnProc(verb: GrafVerb; rgn: RgnHandle);

BEGIN
    { Each verb is different (Frame, Paint, Erase, Fill). }
    AddVerb(verb);
        DebugStr('Rgn')

END;


{ Add colors because we are about to draw a BitMap or PixMap. }

Procedure ColorBitsProc(srcBitsPtr: BitMapPtr; VAR srcRect, dstRect: Rect;
    mode: Integer; maskRgn: RgnHandle);

VAR
    aPixMap:    PixMapPtr;

BEGIN
    { Get the PixMap that we are about to draw.  SrcBits might be a BitMap, or
        one of two different kinds of PixMap pointers.  See GetPixMapPtr for
        more information. }
    aPixMap := GetPixMapPtr(srcBitsPtr);
    IF aPixMap = NIL THEN BEGIN
        { It's just a BitMap; it will use the background and foreground colors. }
        AddRGBBackColor;
        AddRGBForeColor;
    END ELSE
        { It's a PixMap; it has its own color table. }
        AddColorTable(aPixMap^.pmTable);
        DebugStr('BitMap')

END;


{ Beep out, and exit to shell.  A quick way of handling fatal errors, used
    here for simplicity. }

Procedure BeepOut;
BEGIN
    SysBeep (50);
    ExitToShell;                    { We must leave. }
END;


{ Initialize everything, make sure we can run. }

Procedure Initialize;

VAR
    error:                 OSErr;
    theWorld:            SysEnvRec;
    windowRect:    Rect;

BEGIN
    { Test the computer to be sure we can do color.  If not we would crash,
        which would be bad.  If we can’t run, just beep and exit. }
    error := SysEnvirons(1, theWorld);
    IF NOT theWorld.hasColorQD THEN
        BeepOut;            { If no color QD, we must leave. }

    { Initialize all the needed managers. }
    InitGraf(@thePort);
    InitFonts;
    InitWindows;
    InitMenus;
    TEInit;
    InitDialogs(NIL);
    InitCursor;

    { Make a window for drawing in; it must be a color window.  The window
        is full screen size, made smaller to make it more visible. }
    windowRect := screenBits.bounds;
    InsetRect (windowRect, 50, 50);
    gWindow := NewCWindow(NIL, windowRect, 'Carefully Chosen Colors',
        TRUE, documentProc,  Pointer(-1), FALSE, 0);
    SetPort(gWindow);
END;    { Initialize }


{ Read in a PICT file, return NIL if we fail. }

Procedure ReadPicture(VAR aPicture: PicHandle);

CONST
    headerSize = 512;    { PICT files have 512-byte headers. }

VAR
    where:            Point;
    types:            SFTypeList;
    reply:            SFReply;
    error:            OSErr;
    refNum:        Integer;
    fileSize:        LongInt;
    pictureSize:    LongInt;

    { Use this to check error codes and exit if we fail. }

    Procedure Check(error: OSErr);
    BEGIN
        IF error <> noErr THEN BEGIN

            { Get rid of a picture that I might have started reading. }
            IF aPicture <> NIL THEN BEGIN
                DisposHandle(Handle(aPicture));
                aPicture := NIL;
            END;
            { Close the file, if I already opened it. }
            IF refNum <> 0 THEN BEGIN
                error := FSClose(refNum);
                refNum := 0;
            END;

            { Exit out of the whole ReadPicture shebang. }
            EXIT(ReadPicture);
            END;
    END;

BEGIN
    { Set up things so that the Check routine knows we didn't do
        anything yet. }
    aPicture := NIL;
    refNum := 0;

    { Call the Standard File package to open a PICT file.  }
    SetPt(where, 100, 100);
    types[0] := 'PICT';
    SFGetFile(where, '', NIL, 1, types, NIL, reply);

    { If we found a PICT file, open it and read in the picture. }
    IF reply.good THEN BEGIN
        Check(FSOpen(reply.fName, reply.vRefNum, refNum));
        Check(GetEOF(refNum, fileSize));
        { Make a handle to hold the picture.  The picture is everything
            in the file after the header. }
        pictureSize := fileSize - headerSize;
        aPicture := PicHandle(NewHandle(pictureSize));
        Check(MemError);
        { Skip over the header. }
        Check(SetFPos(refNum, fsFromStart,  headerSize));
        { Read in the data. }
        Check(FSRead(refNum, pictureSize, Ptr(aPicture^)));
        Check(FSClose(refNum));
    END;
END;


{ Figure out a color table for a picture. }

Procedure CollectColors(fromPicture: PicHandle; VAR colors: CTabHandle);

VAR
    bottlenecks:    CQDProcs;

BEGIN
    { Create the bottlenecks to figure out the colors.  These bottlenecks
        will figure out what colors are in a picture, but won't draw anything.
        Note that the bottlenecks are installed in thePort, which must be a
        color port. }
    SetStdCProcs(bottlenecks);
    WITH bottlenecks DO BEGIN
        textProc := @ColorTextProc;
        lineProc := @ColorLineProc;
        rectProc := @ColorRectProc;
        rRectProc := @ColorRRectProc;
        ovalProc := @ColorOvalProc;
        arcProc := @ColorArcProc;
        polyProc := @ColorPolyProc;
        rgnProc := @ColorRgnProc;
        bitsProc := @ColorBitsProc;
    END;

    { Create a color table containing black and white. }
    colors := CTabHandle(NewHandle(SizeOfColorTable(1)));
    IF colors <> NIL THEN BEGIN
        WITH colors^^ DO BEGIN
            ctSize := 1; {2 entries}
            WITH ctTable[0].rgb DO BEGIN {first entry is white}
                red := $FFFF;
                green := $FFFF;
                blue := $FFFF;
            END;
            { We have to turn off range checking here so that we can index into
                ctTable.  It is declared as an ARRAY[0..0], but it has more than one
                element. }
            {$PUSH}{$R-}
            WITH ctTable[1].rgb DO BEGIN {second entry is black}
            { This sets the options (range checking) back. }
            {$POP}
                red := 0;
                green := 0;
                blue := 0;
            END;
        END;

        { Now play back the picture to get the colors.  The dstRect doesn't
            matter since our bottlenecks will never actually draw. We use global
            variables (gColorError and gColorTable) to communicate with the
            bottlenecks. }
        thePort^.grafProcs := @bottlenecks;
        gColorError := noErr;
        gColorTable := colors;
        DrawPicture(fromPicture, fromPicture^^.picFrame);
        thePort^.grafProcs := NIL;

        { Fail if error occurred while within the color bottlenecks. }
        IF gColorError <> noErr THEN BEGIN
            DisposHandle(Handle(colors));
            colors := NIL;
        END;
    END;
END;


VAR
    mainPicture:    PicHandle;
    mainColors:        CTabHandle;
    mainPalette:    PaletteHandle;
    mainRect:            Rect;

BEGIN    { Main body of program }
    Initialize;

    { Read in the picture. }
    ReadPicture(mainPicture);
    IF mainPicture = NIL THEN
        BeepOut;

    { Generate a color table for the picture. }
    CollectColors(mainPicture, mainColors);
    IF mainColors = NIL THEN
        BeepOut;

    { Attach a palette to the window (create it from the color table). }
    mainPalette := NewPalette(mainColors^^.ctSize + 1, mainColors,
        pmTolerant, 0);
    IF mainPalette = NIL THEN
        BeepOut;
    SetPalette(gWindow, mainPalette, TRUE);

    { Offset the picture to the top left of the window, and display it. }
    mainRect := mainPicture^^.picFrame;
    OffsetRect(mainRect, -mainRect.left, -mainRect.top);
    IF Button THEN
      SetRect(mainRect,0,0,8,8);
    DrawPicture(mainPicture, mainRect);

    Repeat
    Until Button;
END.    { ColorCollect }